home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Gold Medal Software 3
/
Gold Medal Software - Volume 3 (Gold Medal) (1994).iso
/
prog
/
grafix2.arj
/
CAPTURE.BAS
next >
Wrap
BASIC Source File
|
1993-11-05
|
5KB
|
212 lines
%waittimer=10
' This program is a TSR which reads the current text screen and creates
' a screen 12 image file
DUMMY&=SETMEM(-700000)
DUMMY&=SETMEM(256000)
POPUP KEY CHR$(12,28,&H70) ' ctrl-alt-enter
DO
POPUP SLEEP USING EMS
DEF SEG=&Hb800
O$=PEEK$(0,4000)
Row%=CSRLIN:COL%=POS(0):Cur%=pbvcursorvis
SCREEN 12
p%=1
FOR x%=1 TO 25
FOR y%=1 TO 80
CHAR$=MID$(O$,p%,1)
ATTR??=ASCII(MID$(O$,p%+1,1))
Fg%=(ATTR?? AND &HF)
Bg%=(ATTR?? \ &H10)
CPRINT x%, y%, fg%, bg%, CHAR$
INCR p%:INCR p%
NEXT y%
NEXT x%
PUTSCREEN "CAPTURE.12"
SCREEN 0
DEF SEG=&Hb800
POKE$ 0,O$
MESSAGE "ENTER CAPTURE FILE NAME"
C$=EDITBOX$(" ")
IF DIR$(C$)<>"" THEN KILL C$
NAME "CAPTURE.12" AS C$
LOCATE Row%, Col%, Cur%
POKE$ 0,O$
LOOP
SUB SaveScreen12(R$, G$, B$, I$)
DEF SEG = &HA000
OUT &H3CE, 4: OUT &H3CF, 0:B$=PEEK$(0,32000)
OUT &H3CE, 4: OUT &H3CF, 1:G$=PEEK$(0,32000)
OUT &H3CE, 4: OUT &H3CF, 2:R$=PEEK$(0,32000)
OUT &H3CE, 4: OUT &H3CF, 3:I$=PEEK$(0,32000)
OUT &H3CE, 4: OUT &H3CF, 0:
DEF SEG
END SUB
SUB RestoreScreen12(R$, G$, B$, I$)
DEF SEG = &HA000
OUT &H3C4, 2: OUT &H3C5, 1: POKE$ 0,B$
OUT &H3C4, 2: OUT &H3C5, 2: POKE$ 0,G$
OUT &H3C4, 2: OUT &H3C5, 4: POKE$ 0,R$
OUT &H3C4, 2: OUT &H3C5, 8: POKE$ 0,I$
OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG
END SUB
SUB PUTSCREEN (Fi$)
OPEN Fi$ FOR OUTPUT AS #11
DEF SEG = &HA000
OUT &H3CE, 4: OUT &H3CF, 2:R$=PEEK$(0,32000)
PRINT #11, R$;
OUT &H3CE, 4: OUT &H3CF, 1:r$=PEEK$(0,32000)
PRINT #11, R$;
OUT &H3CE, 4: OUT &H3CF, 0:r$=PEEK$(0,32000)
PRINT #11, R$;
OUT &H3CE, 4: OUT &H3CF, 3:r$=PEEK$(0,32000)
PRINT #11, R$;
OUT &H3CE, 4: OUT &H3CF, 0:
DEF SEG
CLOSE #11
END SUB
SUB GETSCREEN (Fi$)
OPEN Fi$ FOR BINARY AS #11
GET$ #11, 32000, R$
GET$ #11, 32000, G$
GET$ #11, 32000, B$
GET$ #11, 32000, I$
CLOSE #11
DEF SEG = &HA000
OUT &H3C4, 2: OUT &H3C5, 1: POKE$ 0,B$
OUT &H3C4, 2: OUT &H3C5, 2: POKE$ 0,G$
OUT &H3C4, 2: OUT &H3C5, 4: POKE$ 0,R$
OUT &H3C4, 2: OUT &H3C5, 8: POKE$ 0,I$
OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG
END SUB
SUB mload (Filename$)
SOUND 250, .7: DEF SEG = &HA000
OUT &H3C4, 2: OUT &H3C5, 1: BLOAD FileName$ + ".BLU" 'save bit plane 0
OUT &H3C4, 2: OUT &H3C5, 2: BLOAD FileName$ + ".GRN" 'save bit plane 1
OUT &H3C4, 2: OUT &H3C5, 4: BLOAD FileName$ + ".RED" 'save bit plane 2
OUT &H3C4, 2: OUT &H3C5, 8: BLOAD FileName$ + ".INT" 'save bit plane 3
OUT &H3C4, 2: OUT &H3C5, &HF: DEF SEG
SOUND 250, .7
END SUB
SUB CWAIT
T!=TIMER
DO
A$=INKEY$
IF A$=CHR$(27) THEN END
IF TIMER+%WaitTimer > TIMER THEN EXIT LOOP
LOOP WHILE A$=""
END SUB
SUB CPRINT(Y%,X%,Fore%,Back%,Text$)
IF Back%>=0 THEN
M$=STRING$(LEN(Text$),219)
REG 1,&h1300
REG 2,Back%
REG 3,LEN(Text$)
REG 4,256*(Y%-1)+(X%-1)
REG 9,STRSEG(M$)
REG 7,STRPTR(M$)
CALL INTERRUPT &h10
ELSE
Back%=NOT Back%-1
IF Back%=-16 THEN Back%=0
END IF
REG 1,&h1300
REG 2,(Fore% XOR Back%) + &h80
REG 3,LEN(Text$)
REG 4,256*(Y%-1)+(X%-1)
REG 9,STRSEG(Text$)
REG 7,STRPTR(Text$)
CALL INTERRUPT &h10
END SUB
FUNCTION EditBox$(Default$)
COLOR 0,7
CALL SingleBox(19, 38-(LEN(Default$)\2), 21, 42+(LEN(Default$)\2))
y = 40 - (LEN(Default$) \ 2) : YY=0
DO
LOCATE 20,Y,0:PRINT Default$ ' if you want to put the box somewhere
LOCATE 20,Y+yy,1 ' else, change these locate statements
DO:A$=INKEY$:LOOP WHILE LEN(A$)=0
IF LEN(A$) THEN
SELECT CASE(A$)
CASE CHR$(27), CHR$(13)
EXIT SELECT
CASE CHR$(8)
IF YY THEN
YY=YY-1
IF YY THEN
Default$=LEFT$(Default$,yy)+MID$(Default$,yy+2) + " "
ELSE
Default$=MID$(Default$,yy+2) + " "
END IF
END IF
CASE CHR$(0)+CHR$(83)
IF YY THEN
Default$=LEFT$(Default$,yy)+MID$(Default$,yy+2) + " "
ELSE
Default$=MID$(Default$,yy+2) + " "
END IF
CASE CHR$(0)+CHR$(&H4D)
IF YY < LEN(Default$) THEN YY=YY+1
CASE CHR$(0)+CHR$(&H4B)
IF YY THEN YY=YY-1
CASE CHR$(0)+CHR$(79) 'end
yy=LEN(RTRIM$(default$))
CASE CHR$(0)+CHR$(71)
yy=0
CASE ELSE
IF LEN(A$)=1 and YY=0 THEN Default$=SPACE$(LEN(default$))
IF LEN(A$)=1 and YY < LEN(Default$) THEN_
MID$(Default$,YY+1,1) = A$ : YY=YY+1
END SELECT
IF A$=CHR$(27) THEN EditBox$="":EXIT LOOP
IF A$=CHR$(13) THEN EditBox$=RTRIM$(Default$):EXIT LOOP
END IF
LOOP
END FUNCTION
SUB SingleBox (Wa%, Wb%, Wc%, Wd%)
LOCATE Wa%, Wb%: PRINT CHR$(213) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(184)
LOCATE Wc%, Wb%: PRINT CHR$(212) + STRING$((Wd% - Wb%) - 1, 205) + CHR$(190)
FOR zxy% = 1 TO Wc% - Wa% - 1
LOCATE Wa% + zxy%, Wb%
PRINT CHR$(179) + SPACE$((Wd% - Wb%) - 1) + CHR$(179)
NEXT zxy%
END SUB
SUB Message (E$)
CALL SingleBox(14, 20, 16, 60)
LOCATE 15, 40 - (LEN(E$) \ 2)
PRINT E$;
END SUB